home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
HPAVC
/
HPAVC CD-ROM.iso
/
MYMUD21.ZIP
/
MMUD21.ZIP
/
SOURCE
/
SOURCE.ZIP
/
MULTI.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-01-21
|
14KB
|
609 lines
{$I COPYRGHT.INC}
(*---------------------------------------------------------------------------*
This unit contains all the routines nessecary for the multiuser support
*---------------------------------------------------------------------------*)
Unit Multi;
Interface
Uses Dos,
MyIO,
Misc,
Header,
Timer,
BIN_DB,
NewWorld,
Out_Proc;
Const MaxMudNodes = 511;
Var LockLevel : Word;
LockFile : File;
LockStats : LongInt;
LockCalls : LongInt;
DoubleCalls: LongInt;
Type NodeInfoRecord = Record
Player : Integer;
Room : Integer;
Last : LongInt;
Note : String[40];
End;
NodeListType = Array[0..MaxMudNodes] Of NodeInfoRecord;
Var TempDir : PathStr;
Editor : ComStr;
TextPath : ComStr;
WorldPath : ComStr;
Mynode : Integer;
NodeList : NodeListType;
Procedure ReadINI;
Procedure GrabNodeNr;
Procedure FreeNode;
Procedure UpdateNodeInfo(Current : ContextType);
Procedure GrabUserList;
Procedure NotifyAllHere(Name : String;T : TextRecord);
Procedure SayToAllHere(Current : ContextType;S : String);
Procedure GeneralRemarkToAllHere(S : String);
Procedure NotifyAll(T : TextRecord);
Procedure SayToAll(S : String);
Procedure SayPrivate(ObjNr : Integer;S : String);
Procedure ShutDownGame;
Function CheckShutDown:Boolean;
Function CheckResetMe:Boolean;
Procedure ResetPlayerObj(ObjNr : Integer);
Function CheckMail:Boolean;
Procedure ReadMail;
Function IsAlive(ObjNr : Integer):Boolean;
Procedure Lock(Reason : String);
Procedure UnLock;
Procedure ShowLockStat;
Type StatusTypes = (SetSem,DelSem,WaitSem);
SemName = String[8];
Procedure Semafore(Name : SemName;Status : StatusTypes);
Implementation
Procedure Semafore(Name : SemName;Status : StatusTypes);
Var Tmp : file;
TimeOut : TimerObject;
Begin
Case Status Of
SetSem : Begin
Assign(Tmp,TempDir+Name+'.SEM');
Rewrite(Tmp);
Close(Tmp);
If IoResult<>0 Then;
End;
DelSem : Begin
Assign(Tmp,TempDir+Name+'.SEM');
Erase(Tmp);
End;
WaitSem: Begin
TimeOut.SetTimer(50);
Repeat
Until (Not ExistFile(TempDir+Name+'.SEM')) Or TimeOut.TimeUp;
If ExistFile(TempDir+Name+'.SEM')
Then Semafore(Name,DelSem);
End;
End; {Case}
End;
(*--------------------------------------------------------------------------*)
Procedure GrabNodeNr;
Var Search : SearchRec;
Tmp : File;
Begin
MyNode:=1;
FindFirst(TempDir+'InUse.'+Nr2Str(MyNode),AnyFile,Search);
While (DosError=0) And (MyNode<=MaxMudNodes) Do
Begin
Inc(MyNode);
FindFirst(TempDir+'InUse.'+Nr2Str(MyNode),AnyFile,Search);
End;
If MyNode>MaxMudNodes
Then MyNode:=NOTHING
Else Begin
Assign(Tmp,TempDir+'InUse.'+Nr2Str(MyNode));
Rewrite(Tmp);
Close(Tmp);
If IoResult<> 0 Then;
End;
End;
(*--------------------------------------------------------------------------*)
Procedure FreeNode;
Var Tmp : File;
Count : Byte;
Begin
Count:=0;
Repeat
Assign(Tmp,TempDir+'InUse.'+Nr2Str(MyNode));
Erase(Tmp);
If IoResult<>0
Then Inc(Count);
Until (IoResult=0) Or (Count>3);
End;
(*--------------------------------------------------------------------------*)
Procedure ReadINI;
Var IniName : ComStr;
Ini : Text;
Sem : File;
Count : Byte;
Tmp : ContextType;
P : Byte;
Ok : Boolean;
Begin
ININame:=ParamStr(1);
If Pos('.',ININame)>0
Then ININame:=Copy(ININame,1,Pos('.',ININame)-1);
If Not ExistFile(IniName+'.INI')
Then Begin
My_Write('Database not found. Create new database? [y/N]:');
If Upcase(My_ReadKey)='Y'
Then CreateNewWorld(IniName)
Else Halt;
End;
WorldPath:=IniName;
While (WorldPath<>'') And (Not (WorldPath[Length(WorldPath)] in ['\',':'])) Do
Dec(WorldPath[0]);
CompletePath(WorldPath);
Count:=0;
Repeat
Assign(INI,ININame+'.INI');
Reset(INI);
Ok:=IoResult=0;
If Not Ok
Then Begin
Inc(Count);
My_Delay(500);
End;
Until Ok Or (Count>3);
If Count>3
Then Halt(150);
ReadLn(Ini,TempDir);
ReadLn(Ini,Editor);
ReadLn(Ini,TextPath);
Close(Ini);
If IoResult<>0
Then Halt(103);
P:=Pos('~',TempDir);
if P>0
Then Begin
Delete(TempDir,P,1);
Insert(HomeDir,TempDir,P);
End;
P:=Pos('~',TextPath);
if P>0
Then Begin
Delete(TextPath,P,1);
Insert(HomeDir,TextPath,P);
End;
Tmp.Player:=NOTHING;
CompletePath(TextPath);
If Not ExistFile(TextPath+'*.*')
Then Begin
My_WriteLn('TextDir doesn''t exist: '+TextPath);
Halt(0);
End;
CompletePath(TempDir);
If Not ExistFile(TempDir+'*.*')
Then Begin
My_WriteLn('TempDir doesn''t exist: '+TempDir);
Halt(0);
End;
If Not ExistFile(TempDir+'MUDLOCK.SEM')
Then Begin
Assign(Sem,TempDir+'MUDLOCK.SEM');
Rewrite(Sem,1);
Close(Sem);
If IoResult<>0
Then;
End;
If Not ExistFile(Editor)
Then Editor:='';
UpdateNodeInfo(Tmp);
End;
(*--------------------------------------------------------------------------*)
Procedure UpdateNodeInfo(Current : ContextType);
Var NodeInfo : NodeInfoRecord;
Tmp : File of NodeInfoRecord;
D : DateTime;
Dum : Word;
Begin
NodeInfo.Player:=Current.Player;
NodeInfo.Room:=Current.Room;
NodeInfo.Note:=Current.Note;
GetTime(D.Hour,D.Min,D.Sec,dum);
GetDate(D.Year,D.Month,D.Day,Dum);
PackTime(D,NodeInfo.Last);
Lock('Update node info');
FileMode:=ReadWrite+ShareDenyAll;
Assign(Tmp,TempDir+'NODEINFO.DAT');
Reset(Tmp);
If IoResult<>0
Then Rewrite(Tmp);
Seek(Tmp,MyNode);
Write(Tmp,NodeInfo);
Close(Tmp);
If IoResult<>0
Then;
UnLock;
End;
(*--------------------------------------------------------------------------*)
Procedure GrabUserList;
Var Tmp : File;
NodeInfo : NodeInfoRecord;
RR : Word;
Begin
Lock('Nodelist again');
FillChar(NodeList,SizeOf(NodeList),#00);
FileMode:=ReadOnly+ShareDenyNone;
Assign(Tmp,TempDir+'NODEINFO.DAT');
Reset(Tmp,1);
BlockRead(Tmp,NodeList,SizeOf(NodeList),RR);
Close(Tmp);
Unlock;
End;
(*--------------------------------------------------------------------------*)
Function IsAlive(ObjNr : Integer):Boolean;
Var C: Word;
Begin
GrabUserList;
C:=0;
While (C<=MaxMudNodes) And (ObjNr<>NodeList[C].Player) Do
Inc(C);
IsAlive:=(C<MaxMudNodes) {And (C<>MyNode)};
End;
(*--------------------------------------------------------------------------*)
Procedure NotifyAllHere(Name : String;T : TextRecord);
Var out : File;
Len : Word;
C : Word;
RW : Word;
Tries : Word;
Begin
GrabUserList;
If T[0]=#00
Then Exit;
Len:=0;
While T[Len]<>#00 Do
Inc(Len);
If Name<>''
Then Begin
Move(T[0],T[Length(Name)],Len);
Len:=Len+Length(Name);
Move(Name[1],T[0],Length(Name));
End;
Lock('Send message all here');
For C:=0 To MaxMudNodes Do
Begin
If (NodeList[C].Player>0) And (C<>MyNode) And
(NodeList[C].Room=NodeList[MyNode].Room)
Then Begin
FileMode:=ReadWrite+ShareDenyAll;
Assign(Out,TempDir+'Message.'+Nr2Str(C));
Reset(Out,1);
If IoResult<>0
Then Rewrite(Out,1);
Seek(Out,FileSize(Out));
BlockWrite(Out,T,SizeOf(T),RW);
Close(Out);
If IoResult<>0
Then;
End;
End;
Unlock;
End;
(*--------------------------------------------------------------------------*)
Procedure NotifyAll(T : TextRecord);
Var out : File;
C : Word;
RW : Word;
Begin
GrabUserList;
If T[0]=#00
Then Exit;
Lock('Notify all everywhere');
For C:=0 To MaxMudNodes Do
Begin
If (NodeList[C].Player>0) And (C<>MyNode)
Then Begin
FileMode:=ReadWrite+ShareDenyAll;
Assign(Out,TempDir+'Message.'+Nr2Str(C));
Reset(Out,1);
If IoResult<>0
Then Rewrite(Out,1);
Seek(Out,FileSizE(Out));
BlockWrite(Out,T,SizeOf(T),RW);
Close(Out);
If IoResult<>0
Then;
End;
End;
UnLock;
End;
(*--------------------------------------------------------------------------*)
Procedure PrivateMsg(ToPlayer : Word;T : TextRecord);
Var Out : File;
ToNode: Word;
RW : Word;
Begin
GrabUserList;
ToNode:=0;
While (ToNode<=MaxMudNodes) And (NodeList[ToNode].Player<>ToPlayer) Do
Inc(ToNode);
If ToNode>MaxMudNodes
Then Exit;
If T[0]=#00
Then Exit;
Lock('Prv. Message');
If (NodeList[ToNode].Player>0) And (ToNode<>MyNode)
Then Begin
FileMode:=ReadWrite+ShareDenyAll;
Assign(Out,TempDir+'Message.'+Nr2Str(ToNode));
Reset(Out,1);
If IoResult<>0
Then Rewrite(Out,1);
Seek(Out,FileSizE(Out));
BlockWrite(Out,T,SizeOf(T),RW);
Close(Out);
If IoResult<>0
Then;
End;
Unlock;
End;
(*--------------------------------------------------------------------------*)
Procedure SayPrivate(ObjNr : Integer;S : String);
Var T : TextRecord;
Begin
FillChar(T,SizeOf(T),#00);
Move(S[1],T[0],Length(S));
PrivateMsg(ObjNr,T);
End;
(*--------------------------------------------------------------------------*)
Procedure SayToAllHere(Current : ContextType;S : String);
Var T : TextRecord;
Begin
FillChar(T,SizeOf(T),#00);
Move(S[1],T[0],Length(S));
NotifyAllHere(Current.PlayerName,T);
End;
Procedure SayToAll(S : String);
Var T : TextRecord;
Begin
FillChar(T,SizeOf(T),#00);
Move(S[1],T[0],Length(S));
NotifyAll(T);
End;
(*--------------------------------------------------------------------------*)
Procedure GeneralRemarkToAllHere(S : String);
Var T : TextRecord;
Begin
FillChar(T,SizeOf(T),#00);
Move(S[1],T[0],Length(S));
NotifyAllHere('',T);
End;
(*--------------------------------------------------------------------------*)
Function CheckMail:Boolean;
Var S : SearchRec;
Begin
FindFirst(TempDir+'MESSAGE.'+Nr2Str(MyNode),AnyFile,S);
CheckMail:=DosError=0;
End;
(*--------------------------------------------------------------------------*)
Procedure ResetPlayerObj(ObjNr : Integer);
Var Cnt : Integer;
Tmp : File;
Begin
Cnt:=0;
While (Cnt<=MaxMudNodes) And (NodeList[Cnt].Player<>ObjNr) Do
Inc(Cnt);
If Cnt>MaxMudNodes
Then Exit;
Assign(Tmp,TempDir+'RESET.'+Nr2Str(Cnt));
Rewrite(Tmp,1);
Close(Tmp);
If IoResult<>0
Then;
End;
(*--------------------------------------------------------------------------*)
Function CheckResetMe:Boolean;
Var S : SearchRec;
Tmp: File;
Ok : Boolean;
Begin
FindFirst(TempDir+'RESET.'+Nr2Str(MyNode),AnyFile,S);
Ok:=DosError=0;
CheckResetMe:=Ok;
If Ok
Then Begin
Assign(Tmp,TempDir+'RESET.'+Nr2Str(MyNode));
Erase(Tmp);
if IoResult<>0
Then;
End;
End;
(*--------------------------------------------------------------------------*)
Function CheckShutDown:Boolean;
Var S : SearchRec;
Begin
FindFirst(TempDir+'SHUTDOWN.SEM',AnyFile,S);
CheckShutDown:=DosError=0;
End;
(*--------------------------------------------------------------------------*)
Procedure ShutDownGame;
Var Tmp : File;
Begin
Assign(Tmp,TempDir+'SHUTDOWN.SEM');
Rewrite(Tmp);
Close(Tmp);
If IoResult<>0 Then;
End;
(*--------------------------------------------------------------------------*)
Procedure ReadMail;
Var Inp : File of TextRecord;
T : TextRecord;
Begin
FileMode:=ReadOnly+ShareDenyNone;
Lock('Read mail');
Assign(Inp,TempDir+'MESSAGE.'+Nr2Str(MyNode));
Rename(Inp,TempDir+'HANDLED.'+Nr2Str(MyNode));
Unlock;
Reset(Inp);
While Not Eof(Inp) Do
Begin
Read(Inp,T);
WriteText(T);
End;
Close(Inp);
Erase(Inp);
If IoResult<>0
Then Exit;
End;
(*--------------------------------------------------------------------------*)
Procedure Lock(Reason : String);
Var Ok : Boolean;
IOErr : Integer;
TimeOut : TimerObject;
Begin
Inc(LockCalls);
If LockLevel>0
Then Begin
Inc(LockLevel);
Inc(DoubleCalls);
Exit
End
Else LockLevel:=1;
FileMode:=ReadOnly+ShareDenyAll;
Assign(LockFile,TempDir+'MUDLOCK.SEM');
TimeOut.SetTimer(150);
Repeat
Reset(LockFile,1);
IOErr:=IoResult;
Ok:=IoErr=0;
If Not Ok
Then Begin
Inc(LockStats);
{My_Beep;}
My_Delay(300+Random(100));
End;
Until OK or TimeOut.TimeUp;
If Not Ok
Then begin
My_WriteLn('ERROR: '+Reason);
HALT(100);
End;
End;
(*--------------------------------------------------------------------------*)
Procedure UnLock;
Var Regs : Registers;
Begin
If LockLevel>1
then Begin
Dec(LockLevel);
Exit;
End
Else LockLevel:=0;
Close(LockFile);
End;
Procedure ShowLockStat;
Begin
My_WriteLn('Current lock statistics:');
My_WriteLn(' LockLevel : '+Nr2Str(LockLevel));
My_WriteLn(' LockStats : '+Nr2Str(LockStats));
My_WriteLn(' LockCalls : '+Nr2Str(LockCalls));
My_WriteLn(' DoubleCalls: '+Nr2Str(DoubleCalls));
End;
Begin
FillChar(NodeList,SizeOf(NodeList),#00);
MyNode:=0;
LockLevel:=0;
LockCalls:=0;
LockStats:=0;
DoubleCalls:=0;
End.